Baraj Sibiu, august 1996, Ziua 3
Problema 2 (La Groznai - Ion Maxim)

	In cele n intersecii ale orasului Groznai (n<50), numerotate de la 1 la 
n, se afla cate un soldat rus, identificat prin numrul intersectiei. La sosirea 
"in vizita" a comandourilor cecene, soldatii rusi trebuie sa se regrupeze in 
pn puncte (baze) de adunare. 
	Sa se determine amplasamentul celor p baze astfel incat timpul de 
regrupare sa fie minim.
Observatie: 
Toti soldatii circula cu aceeasi viteza, timpul de parcurgere al unei strzi 
fiind cunoscut. Nu exista strazi cu sens unic.

Datele de intrare se afla in fisierul "groznii.txt", ce contine date de forma:
n p
urmata de linii de forma	
i j tij 	- tij fiind timpul de deplasare intre intersectiile i si j
Iesirea se va face in fisierul "baze.txt" de forma:
t	- timp de adunare
urmat de p linii de forma:
b s1 s2 .... sk	- unde b este intersectia aleasa ca baza de soldatii s1 s2 .. sk.
Nota: Bazele vor fi scrise in fisierul de iesire in ordine crescatoare; la fel 
si soldatii regrupati in fiecare baza.
Exemplu:
Pentru intrarea
3 2
1 2 3
2 3 2
o iesire posibila va fi
2
1 1
2 2 3
Timpul maxim de executie pentru fiecare test este de 30 secunde
===========================================
Testul 1:
11 2
1 2 2
2 3 3
4 5 1
5 6 1
6 7 1
7 8 1
8 9 1
10 11 4
--------------------
Testul 2:
16 3
1 2 1
1 4 2
2 3 2
2 4 4
2 5 5
3 5 1
3 6 6
4 5 3
4 11 9
5 6 4
5 9 9
5 10 9
5 11 9
6 7 9
6 9 9
7 8 2
7 9 3
7 15 3
9 10 8
9 15 2
9 16 2
10 11 2
10 13 2
10 14 5
10 16 4
11 12 1
11 13 4
13 14 2
14 16 3
15 16 3
-----------------------
Testul 3:
20 5
1 2 8
2 7 7
2 8 2
3 11 1
3 12 1
4 5 3
4 19 4
4 17 3
4 16 8
4 16 3
5 10 5
6 18 3
6 13 2
7 11 7
7 20 5
7 19 8
7 8 2
7 9 5
8 16 1
9 17 6
9 12 7
9 16 9
10 20 3
10 17 3
10 11 7
10 15 8
11 17 9
11 18 4
11 12 7
12 19 7
12 14 2
12 20 8
12 17 8
12 18 3
13 18 3
14 15 3
14 16 2
14 18 5
15 16 6
15 19 7
16 17 1
17 20 8
18 20 5
19 20 1
-------------------------
Testul 4:
20 8
1 2 8
2 7 7
2 8 2
3 11 1
3 12 1
4 5 3
4 19 4
4 17 3
4 16 8
4 16 3
5 10 5
6 18 3
6 13 2
7 11 7
7 20 5
7 19 8
7 8 2
7 9 5
8 16 1
9 17 6
9 12 7
9 16 9
10 20 3
10 17 3
10 11 7
10 15 8
11 17 9
11 18 4
11 12 7
12 19 7
12 14 2
12 20 8
12 17 8
12 18 3
13 18 3
14 15 3
14 16 2
14 18 5
15 16 6
15 19 7
16 17 1
17 20 8
18 20 5
19 20 1
----------------------
testul 5:
20 10
1 2 8
2 7 7
2 8 2
3 11 1
3 12 1
4 5 3
4 19 4
4 17 3
4 16 8
4 16 3
5 10 5
6 18 3
6 13 2
7 11 7
7 20 5
7 19 8
7 8 2
7 9 5
8 16 1
9 17 6
9 12 7
9 16 9
10 20 3
10 17 3
10 11 7
10 15 8
11 17 9
11 18 4
11 12 7
12 19 7
12 14 2
12 20 8
12 17 8
12 18 3
13 18 3
14 15 3
14 16 2
14 18 5
15 16 6
15 19 7
16 17 1
17 20 8
18 20 5
19 20 1
-----------------------
testul 6:
50 15
1 3 8
2 16 7
2 18 2
3 24 1
3 26 1
4 7 3
4 47 4
4 40 3
4 37 8
4 38 3
5 20 5
6 43 3
6 28 2
7 20 7
7 49 5
7 46 8
7 8 2
7 14 5
8 33 1
9 36 7
9 39 6
9 18 7
9 34 9
10 50 3
10 38 3
10 14 7
10 30 8
11 34 9
11 38 4
11 12 7
12 42 7
12 20 2
12 47 8
12 35 8
12 39 3
13 37 3
14 20 3
14 34 9
14 21 2
14 24 2
14 35 5
15 21 6
15 41 7
16 19 1
17 44 8
18 38 4
18 42 5
19 45 8
19 24 1
20 22 2
21 28 6
21 29 4
21 46 3
21 31 6
22 48 3
22 36 3
22 44 7
22 38 7
23 38 6
23 47 7
23 27 5
24 27 1
24 39 7
24 27 9
25 43 9
25 32 7
25 44 5
25 42 2
25 31 9
26 30 9
26 34 1
27 47 5
28 31 7
28 29 3
28 48 5
28 36 4
29 37 4
29 40 1
29 47 7
29 33 9
29 40 2
30 39 2
30 47 6
30 33 6
30 49 5
30 37 5
31 35 7
31 50 6
32 42 1
32 46 2
32 37 8
32 45 4
33 36 1
33 37 1
33 40 4
33 40 1
33 41 5
34 45 8
34 44 3
34 40 6
35 45 3
35 46 6
35 49 4
35 41 6
35 47 5
36 46 8
36 47 9
37 48 3
38 47 5
38 50 2
39 42 9
40 49 7
40 50 3
41 49 1
41 44 1
42 46 1
42 44 7
42 45 4
43 45 2
43 46 1
43 48 3
44 48 6
44 50 1
44 46 8
44 49 1
45 46 4
46 47 1
46 49 7
47 48 5
47 49 2
47 50 5
48 50 9
48 49 2
49 50 6
-----------------------------
Solutie (Rodica Pintea si Dana Lica)
{$R+}
program groznii;
const maxx=50;
type tablou=array[1..maxx,1..maxx]of longint;
var n,p,i,j,k,cmin:integer; nume:string[12];
    c,s,sopt,copt:array[0..maxx]of byte;
    luat:array[1..maxx]of boolean;
    a,d:tablou;       nsol:byte;
procedure citeste;
var f:text;
begin
     write(' Nume fisier :');
     readln(nume);
     assign(f,nume);reset(f);
     readln(f,n,p);
     for i:=1 to n do
         for j:=1 to n do
             if i<>j then a[i,j]:=30000;
     while not seekeof(f) do begin
           readln(f,i,j,a[i,j]);a[j,i]:=a[i,j]
     end;
     close(f)
end;
procedure scrie;
begin
     if cmin=30000 then begin writeln('No solution');halt end;
     writeln(cmin:10);
     for i:=1 to p do begin
         write(copt[i]:3);
         for j:=1 to n do
             if sopt[j]=copt[i] then write(j:3);
         writeln
     end
end;
procedure floyd;
begin
     d:=a;
     for k:=1 to n do
         for i:=1 to n do
             for j:=1 to n do
                 if d[i,k]+d[k,j]<d[i,j] then d[i,j]:=d[i,k]+d[k,j]
end;
procedure cost;
var cpr,min,i,j:integer;
begin
     cpr:=0;
     for i:=1 to n do begin
         min:=maxint;
         for j:=1 to p do
             if d[i,c[j]]<min then begin
                min:=d[i,c[j]];s[i]:=c[j]
             end;
         if min>cpr then cpr:=min
     end;
     if cpr<=cmin then begin
        if cpr=cmin then inc(nsol) else nsol:=0;
        cmin:=cpr;sopt:=s;copt:=c;scrie
     end
end;
procedure comb(i:byte);
var k:byte;
begin
     if i>p then
        cost
     else for k:=1 to n do
              if not luat[k] and (k>c[i-1]) then begin
                 luat[k]:=true;
                 c[i]:=k;
                 comb(i+1);
                 luat[k]:=false
              end
end;
begin
      citeste;
      floyd;
      cmin:=maxint;
      c[0]:=0;
      comb(1);
      scrie;writeln(nsol);readln
end.
------------------------
Solutia 1: {Badoiu Mihai}
{$A+,B-,D-,E-,F-,G+,I-,L-,N+,O-,P-,Q-,R-,S-,T-,V+,X+,Y-}
{$M 65520,0,655360}
const
	max=52;
type
	ttip=array[1..max] of longint;
var
	timp:longint absolute $0:$46c;
	itimp:longint;
	mo:longint;
	n,p:integer;
	v:array[1..max,1..max] of longint;
	vo,t:array[1..max] of byte;
	timpio,timpi:ttip;

procedure init;
var
	i,j:integer;
begin
	for i:=1 to n do
		for j:=1 to n do
			v[i,j]:=16000000;
	for i:=1 to n do
	begin
		v[i,i]:=0;
		timpi[i]:=32000000;
		end;
end;

procedure load;
var
	f:text;
	a,b,c:longint;
begin
	assign(f,'groznii.txt');
	reset(f);
	readln(f,n,p);
	init;
	while not seekeof(f) do
	begin
		readln(f,a,b,c);
		v[a,b]:=c;
		v[b,a]:=c;
		end;
	close(f);
end;

procedure select(a:integer);
var
	i:integer;
begin
	for i:=1 to n do
	if v[i,a]<timpi[i] then
	begin
		timpi[i]:=v[i,a];
		end;
end;

procedure scs;
var
	i:integer;
	m:longint;
begin
	m:=0;
	for i:=1 to n do
		if m<timpi[i] then
			m:=timpi[i];
	if m<mo then
	begin
		timpio:=timpi;
		mo:=m;
		vo:=t;
		end;
end;

procedure euristic;
var
	i,j,k,m:integer;
begin
	for j:=1 to n do
		t[j]:=0;
	for i:=1 to n do
	begin
		for j:=1 to n do
			timpi[j]:=3200000;
		t[i]:=1;
		select(i);
		for k:=1 to p-1 do
		begin
			m:=1;
			for j:=1 to n do
			if timpi[j]>timpi[m] then
			begin
				m:=j;
				end;
			t[m]:=1;
			select(m);
			end;
		scs;
		for j:=1 to n do
			t[j]:=0;
		end;
	for j:=1 to n do
		timpi[j]:=32000000;
end;

procedure back(p,i:integer);
var
	ss:ttip;
begin
	if timp-itimp>500 then
		exit;
	if n-i<p then
		exit;
	if p=0 then
		scs
	else
	begin
		for i:=i+1 to n do
		begin
			t[i]:=1;
			ss:=timpi;
			select(i);
			back(p-1,i);
			timpi:=ss;
			t[i]:=0;
			end;
		end;
end;

procedure calcul;
var
	i,j,k:integer;
begin
	for k:=1 to n do
		for i:=1 to n do
			for j:=1 to n do
			if v[i,j]>v[i,k]+v[k,j] then
				v[i,j]:=v[i,k]+v[k,j];
	euristic;
	back(p,0);
end;

procedure scrie;
var
	f:text;
	i,j:integer;
	k:longint;
begin
	assign(f,'baze.txt');
	rewrite(f);
	k:=0;
	for i:=1 to n do
	if timpio[i]>k then
		k:=timpio[i];
	writeln(f,k);
	for i:=1 to n do
		t[i]:=0;
	for i:=1 to n do
	if vo[i]<>0 then
	begin
		write(f,i);
		for j:=1 to n do
			if (timpio[j]=v[j,i]) and (t[j]=0) then
			begin
				write(f,' ',j);
				t[j]:=1;
				end;
		writeln(f);
		end;
	close(f);
end;

begin
	itimp:=timp;
	mo:=30003424;
	load;
	calcul;
	scrie;
end.
-------------------
Solutia 2: {Valentin Gheorghita}
program ceceni;
uses crt;
const maxim=50;
type sir=array[1..maxim,1..maxim] of integer;
var time,times,a,baza:sir;
    f:text;
    sel:array[1..maxim] of boolean;
    t,d,go,poz:array[1..maxim] of integer;
    max,i,j,k,n,p,tmp,vf,min:integer;

function ramas:boolean;
 var a:array[1..50] of boolean;
     k,i:integer;
  begin
   for i:=1 to n do
    a[i]:=false;
   for i:=1 to n do
    a[go[i]]:=true;
   k:=0;
   for i:=1 to n do
    if a[i] then inc(k);
   if k>p then ramas:=false
          else ramas:=true;
  end;

function adauga:integer;
  var i,min,pz:integer;
 begin
  min:=maxint;
  pz:=0;
  for i:=1 to n do
   if (poz[i]<n) and (min>time[i,poz[i]+1]) then begin
                                 min:=time[i,poz[i]+1];
                                 pz:=i;
                                end;
  inc(poz[pz]);
  go[pz]:=baza[pz,poz[pz]];
  adauga:=go[pz];
 end;

procedure verifica(vf:integer);
 var i:integer;
  begin
   for i:=1 to n do
     for j:=1 to poz[i] do
      if baza[i,j]=vf then if time[i,j]<>-1 then go[i]:=vf;
  end;

begin
 clrscr;
 assign(f,'groznii.txt');
 reset(f);
 readln(f,n,p);
 for i:=1 to n do
  for j:=1 to n do
   begin
    a[i,j]:=0;
    baza[i,j]:=j;
   end;
 while(not(seekeof(f))) do begin
                            read(f,i,j);
                            readln(f,a[i,j]);
                            a[j,i]:=a[i,j];
                           end;
 close(f);
 for tmp:=1 to n do
  begin
   for i:=1 to n do
    begin
     sel[i]:=false;
     if a[tmp,i]<>0 then begin
                          t[i]:=tmp;
                          d[i]:=a[tmp,i];
                         end
                    else begin
                          t[i]:=0;
                          d[i]:=-1;
                         end;

    end;
   sel[tmp]:=true;
   for k:=1 to n-1 do
    begin
     min:=maxint;
     vf:=0;
     for i:=1 to n do
      if not(sel[i]) and (min>d[i]) and (d[i]>0) then begin
                                                       min:=d[i];
                                                       vf:=i;
                                                      end;
     if vf<>0 then begin
                    sel[vf]:=true;
                    for i:=1 to n do
                     if ((d[i]>d[vf]+a[vf,i]) or (d[i]=-1)) and (a[vf,i]>0)
                                           then begin
                                                 d[i]:=d[vf]+a[vf,i];
                                                 t[i]:=vf;
                                                end;
                   end;
    end;
   for i:=1 to n do
    time[tmp,i]:=d[i];
  time[tmp,tmp]:=0;
 end;
 times:=time;
 for tmp:=1 to n do
  for i:=1 to n-1 do
   for j:=i+1 to n do
    if time[tmp,i]>time[tmp,j] then begin
                                     k:=time[tmp,i];
                                     time[tmp,i]:=time[tmp,j];
                                     time[tmp,j]:=k;
                                     k:=baza[tmp,i];
                                     baza[tmp,i]:=baza[tmp,j];
                                     baza[tmp,j]:=k;
                                    end;
 for i:=1 to n do
  go[i]:=i;
 for i:=1 to n do
  begin
   poz[i]:=1;
   while(not(time[i,poz[i]]=0)) do inc(poz[i]);
  end;
 while(not(ramas)) do begin
                       min:=adauga;
                       verifica(min);
                      end;
 max:=0;
 for i:=1 to n do
  if times[i,go[i]]>max then max:=times[i,go[i]];
 assign(f,'baze.txt');
 rewrite(f);
 writeln(f,max);
 for i:=1 to n do
  sel[i]:=false;
 for i:=1 to n do
  sel[go[i]]:=true;
 for i:=1 to n do
  if sel[i] then begin
                  write(f,i);
                  for j:=1 to n do
                   if go[j]=i then write(f,' ',j);
                  writeln(f);
                 end;
 close(f);
end.
-----------------------
Solutia 3 (Mihai Stroe)
    Programul incepe prin aplicarea algoritmului lui Floyd in graf.
    Pasul urmator consta in determinarea componentelor conexe ale grafului.
  In cazul in care numarul acestora este mai mare decat numarul bazelor,
  problema nu are solutie. Daca cele doua numere sunt egale, solutia este
  aflata polinomial, cautandu-se centrul fiecarei componente.
    Daca problema nu este inca rezolvata, se genereaza combinari, iar la
  fiecare pas se pastreaza timpul minim in care se poate ajunge de la fiecare
  nod la una din baze; nodurile pentru care acest timp este mai mic decat
  optimul partial sunt introduse intr-o multime, pe fiecare nivel al stivei.
  Daca multimea cuprinde toate nodurile, se actualizeaza optimul si se refac
  multimile de la nivelele precedente ale stivei. Se afiseaza solutia
  partiala, daca programul nu se termina in 30 de secunde.
var nrcomp,t,tmin,tl,th,topt,tl1,nrt,i,j,k,l,m,n,nr:longint;
    tl2:longint absolute $0:$46c;
    fi,fo:text;
    a:array[1..50,1..50]of byte;
    comp:array[0..50]of set of byte;
    st:array[0..50]of byte;
    luate,sol:set of byte;
    timp:array[0..50,1..50]of byte;
    lu:array[0..50]of set of byte;
    s:string;

procedure readdata;
begin
  fillchar(a,sizeof(a),255);
  tl1:=tl2;
  readln(s);
  assign(fi,s);
  assign(fo,'baze.txt');
  reset(fi);
  readln(fi,n,nr);
  while not seekeof(fi) do
    begin
      readln(fi,i,j,a[i,j]);
      a[j,i]:=a[i,j];
    end;
  close(fi);
end;

procedure nosol;
begin
  writeln(fo,'Soldatii sunt in ',nrcomp,' regiuni conexe maximale disjuncte si nu se pot');
  writeln(fo,'regrupa in ',nr,' baze');
  close(fo);
end;

procedure floyd;
begin
  for k:=1 to n do
      for i:=1 to n do
          for j:=1 to n do
              if a[i,j]>a[i,k]+a[k,j] then
                 a[i,j]:=a[i,k]+a[k,j];
  for i:=1 to n do a[i,i]:=0;
end;

procedure detconex;
begin
  luate:=[];
  nrcomp:=0;
  while luate<>[1..n] do
    begin
      inc(nrcomp);
      i:=1;while (i in luate)do inc(i);
      for j:=1 to n do
          if a[i,j]<20 then
             begin
               comp[nrcomp]:=comp[nrcomp]+[j];
               luate:=luate+[j];
             end;
    end;
end;

procedure solvecomp;
var i,k,rad,min,x,j:longint;
begin
  writeln(fo,topt);
  for i:=1 to nrcomp do
      begin
        rad:=0;min:=200;
        for j:=1 to n do
            if j in comp[i] then
            begin
              x:=0;
              for l:=1 to n do
                  if l in comp[i] then
                     if a[j,l]>x then x:=a[j,l];
              if x<min then begin min:=x;rad:=j;end;
            end;
        write(fo,rad);
        for j:=1 to n do
            if j in comp[i] then write(fo,' ',j);
        writeln(fo);
      end;
  close(fo);
end;

procedure solveeur;
var i,k,rad,min,x,j:longint;
begin
  for i:=1 to nrcomp do
      begin
        rad:=0;min:=200;
        for j:=1 to n do
            if j in comp[i] then
            begin
              x:=0;
              for l:=1 to n do
                  if l in comp[i] then
                     if a[j,l]>x then x:=a[j,l];
              if x<min then begin min:=x;rad:=j;end;
            end;
        sol:=sol+[rad];
      end;
end;

procedure react(k:longint);
var i,j:longint;
begin
  sol:=[];
  for i:=1 to k-1 do
      sol:=sol+[st[i]];
  topt:=0;
  for i:=1 to n do
      if timp[k-1,i]>topt then topt:=timp[k-1,i];
  for i:=1 to k do
      begin
        lu[i]:=[];
        for j:=1 to n do
            if timp[i,j]<topt then lu[i]:=lu[i]+[j];
      end;
end;

procedure rec(k,p:longint);
var i,j:longint;
begin
  if tl2-tl1>650 then exit;
  if (lu[k-1]=[1..n]) then react(k);
  if p=0 then exit;
  for i:=st[k-1]+1 to n do
      begin
        timp[k]:=timp[k-1];
        lu[k]:=lu[k-1];
        st[k]:=i;
        for j:=1 to n do
            if timp[k,j]>a[i,j] then
               begin
                 timp[k,j]:=a[i,j];
                 if timp[k,j]<topt then lu[k]:=lu[k]+[j];
               end;
        rec(k+1,p-1);
      end;
end;

procedure solve;
begin
  topt:=255;
  rewrite(fo);
  floyd;
  detconex;
  if nrcomp>nr then begin nosol;halt;end;
  topt:=0;
  for i:=1 to nrcomp do
      begin
        k:=200;
        for j:=1 to n do
            if j in comp[i] then
               begin
                 m:=0;
                 for l:=1 to n do
                     if(l in comp[i])and(a[j,l]>m)then m:=a[j,l];
                 if m<k then k:=m;
               end;
        if k>topt then topt:=k;
      end;
  if nr=nrcomp then begin solvecomp;halt;end;
  solveeur;
  for i:=1 to n do timp[0,i]:=200;
  rec(1,nr);
  writeln(fo,topt);
  k:=0;
  while k<>nr do
    begin
      k:=0;
      for i:=1 to n do
          if i in sol then inc(k);
      if k<>nr then
         begin
           k:=k+1;
           i:=1;
           while i in sol do inc(i);
           sol:=sol+[i];
         end;
    end;
  luate:=[];
  for i:=1 to n do
      if i in sol then
         begin
           write(fo,i);
           for j:=1 to n do
               if (not(j in luate))and(a[i,j]<=topt)then
                  begin
                    write(fo,' ',j);
                    luate:=luate+[j];
                  end;
           writeln(fo);
         end;
  close(fo);
end;

begin
  readdata;
  solve;
  writeln(topt);
end.
------------------------------
